Pascal Super Library/Pascal Super Library (CW International)(1997).bin/DELPHI32/SEARCH/RUBICON/WILDCARD.PAS

Pascal/Delphi Source File | 1996-10-21 | 5KB | 194 lines

{************************************************************************
 WildMatcher - a string matcher that understands * and ?

 Written 1/13/90, Kim Kokkonen, TurboPower Software
 Updated 3/08/91 to allow specification of a dup trigger point (/n)
 CompuServe ID [76004,2611]
 Updated 7/28/94 to stand alone BP7 unit and
 Updated 3/15/95 to Delphi class by Deven Hickingbotham, Tamarack Associates
************************************************************************}

{$R-,S-,I-,V-,B-,F-,G+}
{$IFDEF Win32}
{$LONGSTRINGS OFF}
{$ENDIF}

unit WildCard;

interface

uses SysUtils;

const
  EndChar = #255;        {Terminator to match strings}

type
    TWildMatcher = class(TObject)
      private
      maAny  : Char;
      maOne  : Char;
      maCase : Boolean;       {True if case-sensitive matching}
      maMask : String;   {Mask used for matching}
      procedure SetAnyChar(Value : Char);
      procedure SetMask(Value : String);
      procedure SetOneChar(Value : Char);
      public
      constructor Create;
        {-Create the mask string}
      constructor Init(AMask : String ; ACaseSensitive : Boolean ; AAnyChar,AOneChar : Char);
        {-Initialize the mask string}
      function Matches(Name : String) : Boolean;
        {-Return True if Name matches Mask}
      function GetMask : String;
        {-Return the simplified mask}
      procedure SimplifyMask;
        {-Used internally to simplify mask when object instantiated}
      property AnyChar : Char read maAny write SetAnyChar;
      property CaseSensitive : Boolean read maCase write maCase;
      property Mask : String read maMask write SetMask;
      property OneChar : Char read maOne write SetOneChar;
    end;

    EWildCard = Class(Exception);

implementation

constructor TWildMatcher.Create;
begin
  inherited Create;
  maAny := '*';
  maOne := '?';
  maCase := False;
  maMask := '';
end;

constructor TWildMatcher.Init(AMask : String ; ACaseSensitive : Boolean ;
                              AAnyChar,AOneChar : Char);
begin
  inherited Create;
  AnyChar := AAnyChar;
  CaseSensitive := ACaseSensitive;
  Mask := AMask;
  OneChar := AOneChar;
end;

procedure TWildMatcher.SetAnyChar(Value : Char);
begin
  if Value <> maOne then maAny := Value
  else raise EWildCard.Create('AnyChar = OneChar')
end;

procedure TWildMatcher.SetMask(Value : String);
begin
  if length(Value) >= 128 then
    raise EWildCard.Create('Mask length too long')
  else
    if Value <> maMask THEN
      begin
        maMask := Value;
        SimplifyMask;
        maMask[Length(maMask)+1] := EndChar;
      end
end;

procedure TWildMatcher.SetOneChar(Value : Char);
begin
  if Value <> maAny then maOne := Value
  else raise EWildCard.Create('AnyChar = OneChar')
end;

function TWildMatcher.Matches(Name : String) : Boolean;
  {-Return True if Name matches Mask}
var
  NLen : Byte absolute Name;
  MPos : Word;
  NPos : Word;
  MPSave : Word;
  NPSave : Word;
  AnyOn : Boolean;
  Ch : Char;
begin
  Matches := False;

  {Add terminator to input string}
  Name[NLen+1] := EndChar;

  AnyOn := False;
  MPos := 1;
  NPos := 1;

  while (maMask[MPos] <> EndChar) or (Name[NPos] <> EndChar) do begin
    {Look for '*'}
    if maMask[MPos] = maAny then begin
      if MPos >= Length(maMask) then begin
        {Last character in maMask is '*', rest must match}
        Matches := True;
        Exit;
      end;
      AnyOn := True;
      NPSave := NPos;
      inc(MPos);
      MPSave := MPos;
    end;

    {Get next character from Name string}
    if maCase then
      Ch := Name[NPos]
    else
      Ch := UpCase(Name[NPos]);

    {Look for literal match}
    if (Ch <> EndChar) and ((maMask[MPos] = maOne) or (maMask[MPos] = Ch))
    then begin
      {Matching character}
      inc(MPos);
      inc(NPos);
    end else begin
      {Mismatched character}
      if not AnyOn or (NPSave >= Length(Name)) then
        {Fatal mismatch, no '*' in effect or no way to advance past mismatch}
        Exit;
      {Increment restart point}
      inc(NPSave);
      {Try again at next Name position}
      NPos := NPSave;
      {Restart maMask just after the '*'}
      MPos := MPSave;
    end;
  end;

  Matches := True;
end;

function TWildMatcher.GetMask : String;
  {-Return the simplified mask}
begin
  GetMask := maMask;
end;

procedure TWildMatcher.SimplifyMask;
  {-Used internally to simplify mask when object instantiated}
var
  MLen : Byte;
  MPos : Word;
  OMask : String;
  OLen : Byte absolute OMask;
begin
  MLen := Length(maMask);
  MPos := 1;
  OLen := 0;
  while MPos <= MLen do begin
    if (MPos = 1) or (maMask[MPos] <> maAny) or (maMask[MPos-1] <> maAny) then begin
      {Transfer maMask to OMask, skipping repeated asterisks}
      inc(OLen);
      OMask[OLen] := maMask[MPos];
      if not maCase then
        OMask[OLen] := UpCase(OMask[OLen]);
    end;
    inc(MPos);
  end;
  maMask := OMask;
end;

end.